home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1997 September / Macworld (1997-09).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / shellMode.tcl < prev    next >
Encoding:
Text File  |  1997-05-29  |  13.2 KB  |  536 lines  |  [TEXT/ALFA]
  1.  
  2. ################################################################################
  3. # Shell routines.
  4. ################################################################################
  5.  
  6. if $startingUp {
  7.     addMode Shel dummyShel {"*tcl\ sh*"} { tclMenu }
  8.     newModeVar Shel wordBreak {(\$)?[a-zA-Z0-9_.]+} 0
  9.     newModeVar Shel wordWrap {0} 1
  10.     newModeVar Shel wordBreakPreface {[^a-zA-Z0-9_\$]} 0
  11.     newModeVar Shel autoMark    0    1
  12.     regModeKeywords -m {«} Shel {}
  13.     return
  14. }
  15.  
  16.  
  17. set otherDirs {}
  18.  
  19. proc pushd {args} {
  20.     global otherDirs
  21.     if {[string length $args]} {
  22.         set otherDirs [cons [pwd] $otherDirs]
  23.         cd [string trim [eval list $args] "        \{\}"]
  24.     } else {
  25.         if {[llength $otherDirs]} {
  26.             set n [car $otherDirs]
  27.             set otherDirs [cons [pwd] [cdr $otherDirs]]
  28.             cd $n
  29.         } else {
  30.             return "No other directories"
  31.         }
  32.     }
  33. }
  34. proc pd {args} {
  35.     if {[string length $args]} {
  36.         eval pushd $args
  37.     } else {
  38.         pushd
  39.     }
  40. }
  41.  
  42.  
  43. proc dirs {} {global otherDirs; cons [pwd] $otherDirs}
  44.  
  45. proc popd {} {
  46.     global otherDirs
  47.     if {[llength $otherDirs]} {
  48.         cd [car $otherDirs]
  49.         set otherDirs [cdr $otherDirs]
  50.     } else {
  51.         return "No other directories"
  52.     }
  53. }
  54.  
  55. proc folder {} {
  56.     switchTo Finder
  57.     openFolder [pwd]
  58. }
  59.  
  60.  
  61. proc setShellMode {} {
  62.     setTclMode
  63.     changeMode "Shel"
  64.     insertMenu "Tcl"
  65. }
  66.  
  67. proc initShell {} {
  68.     insertText "Welcome to Alpha's Tcl shell."
  69.     insertText -w [lindex [winNames] 0] [shellPrompt]
  70. }
  71.  
  72. # Return the prompt. We want the window name because some of the commands
  73. # we evaluate (such as 'edit') open a new window, and we want the insertion
  74. # to be done in the shell window.
  75. proc shellPrompt {} {
  76.     return "\r«[file tail [string trimright [pwd] {:}]]» "
  77. }
  78.  
  79.  
  80. proc shellCarriageReturn {} {
  81.     global mode histnum
  82.     global _text
  83.     global _returnText
  84.     set pos [getPos]
  85.  
  86.     if {![catch {regexp {∞} [getText $pos [nextLineStart $pos]]} res] && $res} {
  87.         gotoMatch; return;
  88.     }
  89.     set ind [string first "»" [getText [lineStart $pos] $pos]]
  90.     if {$ind < 0} {
  91.         carriageReturn
  92.         return
  93.     }
  94.     set lStart [expr [lineStart $pos]+$ind+2]
  95.     endOfLine
  96.     set _text [getText $lStart [getPos]]
  97.     set fileName [lindex [winNames] 0]
  98.     if {[getPos] != [maxPos]} {
  99.         goto [maxPos]
  100.         insertText -w $fileName $_text
  101.     }
  102.     if {[string first "Toolserver" $fileName] != -1} {
  103.         if {![catch {dosc -n ToolServer -s $_text} _returnText]} {
  104.             insertText "\r" $_returnText
  105.         } else {
  106.             insertText "\r"
  107.         }
  108.         mpwPrompt
  109.     } elseif {$fileName == "* Comet Server *"} {
  110.         cometSendAndPrompt $_text
  111.     } else {
  112.         uplevel #0 {catch $_text _returnText}
  113.         history add $_text
  114.         if {[string length $_returnText]} {
  115.             insertText -w $fileName "\r" $_returnText [shellPrompt]
  116.         } else {
  117.             insertText -w $fileName [shellPrompt]
  118.         }
  119.         set histnum [history nextid]
  120.     }
  121.     unset _text
  122.     unset _returnText
  123. }
  124. bind '\r' carriageReturn
  125. bind '\r' shellCarriageReturn "Shel"
  126. bind '\r' shellCarriageReturn "MPW"
  127.  
  128.  
  129. bind up <z> prevHist Shel
  130. bind down <z> nextHist Shel
  131.  
  132. proc prevHist {} {
  133.     global histnum
  134.     
  135.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  136.     if {[set ind [string first "» " $text]] > 0} {
  137.         goto [expr [lineStart [getPos]] + $ind + 2]
  138.     } else return
  139.  
  140.     incr histnum -1
  141.     if {[catch {history event $histnum} text]} {
  142.         incr histnum
  143.         endOfLine
  144.         return
  145.     }
  146.     set to [nextLineStart [getPos]]
  147.     if {[lookAt [expr $to-1]] == "\r"} {incr to -1}
  148.     replaceText [getPos] $to $text
  149. }
  150.  
  151.  
  152. proc nextHist {} {
  153.     global histnum
  154.     
  155.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  156.     if {[set ind [string first "» " $text]] > 0} {
  157.         goto [expr [lineStart [getPos]] + $ind + 2]
  158.     } else return
  159.  
  160.     incr histnum
  161.     if {[catch {history event $histnum} text]} {
  162.         incr histnum -1
  163.         endOfLine
  164.         return
  165.     }
  166.     set to [nextLineStart [getPos]]
  167.     if {[lookAt [expr $to-1]] == "\r"} {incr to -1}
  168.     replaceText [getPos] $to $text
  169. }
  170.  
  171.     
  172. proc startMPW {} {
  173.     global toolserverPath
  174.  
  175.     if {![string length [checkRunning ToolServer MPSX toolserverPath]]} return
  176.  
  177.     insertText "Welcome to Alpha's MPW shell (using ToolServer via AppleEvents)."
  178.     bind '\r' shellCarriageReturn "MPW"
  179.     carriageReturn
  180.     mpwPrompt
  181. }
  182. proc mpwPrompt {} {
  183.     insertText "«mpw» "
  184. }
  185.  
  186. proc setMPWMode {} {
  187.     changeMode "MPW"
  188. }
  189.  
  190. #    shellCarriageReturn
  191.  
  192.  
  193.  
  194. #=============================================================================
  195. #    Shell Aliases
  196. #=============================================================================
  197.  
  198.  
  199. proc l {args} {
  200.     eval [concat "ls -CF" $args]}
  201.  
  202. proc ll {args} {
  203.     eval [concat "ls -l" $args]}
  204.  
  205.  
  206. proc wc {args} {
  207.     set res {}
  208.     set totChars 0
  209.     set totLines 0
  210.     set totWords 0
  211.     set args [glob -nocomplain $args]
  212.     foreach file $args {
  213.         set id [open $file]
  214.         set chars [string length [set text [read $id]]]
  215.         set lines [llength [split $text "\n"]]
  216.         set words [llength [split $text]]
  217.         append res [format "\r%8d%8d%8d    $file" $lines $words $chars]
  218.         set totChars [expr $totChars+$chars]
  219.         set totWords [expr $totWords+$words]
  220.         set totLines [expr $totLines+$lines]
  221.         close $id
  222.     }
  223.     if {[llength $args] > 1} {
  224.         append res [format "\r%8d%8d%8d    total" $totLines $totWords $totChars]
  225.     }
  226.     return [string range $res 1 end]
  227. }
  228.  
  229. #================================================================================
  230.  
  231.  
  232. proc tclFileCompletion {} {
  233.     set silly "*"
  234.     set pos [getPos]
  235.     set res [search -f 0 -i 0 -m 0 -r 1 -n {["\{ \t\r]} [expr $pos - 1]]
  236.     if {[string length $res]} {
  237.         set from [lindex $res 1]
  238.         if {$from < $pos} {
  239.             set pd [pwd]
  240.             set text [getText $from $pos]
  241.             if {[string index $text 0] == ":"} {
  242.                 set pd [string trimright $pd ":"]
  243.             }
  244.             if {[catch {glob $pd$text$silly} globbed]} {
  245.                 set globbed [glob $text$silly]
  246.                 set pd ""
  247.             }
  248.             if {[llength $globbed] == 1} {
  249.                 set len [string length $pd$text]
  250.                 insertText [string range [lindex $globbed 0] $len end]
  251.             } elseif {[llength $globbed] != 0} {
  252.                 set globbed [lsort $globbed]
  253.                 set one [lindex $globbed 0]
  254.                 set two [lindex $globbed end]
  255.                 
  256.                 set len [string length $pd$text]
  257.                 set one [string range $one $len end]
  258.                 set two [string range $two $len end]
  259.                 
  260.                 set elen [string length $one]
  261.                 if {[string length $two] < $elen} {
  262.                     set elen [string length $two]
  263.                 }
  264.                 set len 0
  265.                 set str ""
  266.                 while {($len < $elen) && ([string match $str[string index $one $len]$silly $two])} {
  267.                     append str [string index $one $len]
  268.                     incr len
  269.                 }
  270.  
  271.                 if {!$len} {
  272.                     set elen [string length $pd]
  273.                     foreach g $globbed {
  274.                         lappend short [string range $g $elen end]
  275.                     }
  276.                     set blah [getText [lineStart [getPos]] [getPos]]
  277.                     insertText "\r" $short "\r" $blah
  278.                 } else {
  279.                     insertText $str
  280.                 }
  281.             }
  282.         }
  283.     }
  284. }
  285.  
  286.  
  287.  
  288. #================================================================================
  289. # To prevent ambiguity, 'from' is assumed to be a complete pathname, ending
  290. # in a directory name. If it doesn't end w/ a colon, one is added. 'to' is
  291. # assumed to be the parent directory of the top directory we are creating.
  292. #================================================================================
  293. proc cpdir {from to} {
  294.     set cwd [pwd]
  295.     if {[string match ":*" $from] || [string match ":*" $to] ||
  296.         ![file exists $from] || ![file exists $to]} {
  297.         error "'cpdir' args must be complete pathnames of existing folders."
  298.     }
  299.     if {![string match "*:" $from]} {append from ":"}
  300.     if {![string match "*:" $to]} {append to ":"}
  301.     
  302.     if {![file isdir $from] || ![file isdir $to]} {
  303.         exit 1
  304.     }
  305.         
  306.     set res [catch {cphier $from $to} val]
  307.     cd $cwd
  308.     if {$res} {error $val}
  309. }
  310.  
  311. proc cphier {from to} {
  312.     set savedir [pwd]
  313.     if {[string index $from [expr [string len $from] - 1]] != ":"} {append from ":"}
  314.     set dir [file tail [string trimright $from ":"]]
  315.     cd $to
  316.     mkdir "$dir"
  317.     foreach f [glob "$from*"] {
  318.         if {[file isdir $f]} {
  319.             cphier "$f:" "$to$dir:"
  320.         } else {
  321.             cp $f $to$dir:
  322.         }
  323.     }
  324.     cd $savedir
  325. }
  326.  
  327.  
  328. proc shellBol {} {
  329.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  330.     if {[set ind [string first "» " $text]] > 0} {
  331.         goto [expr [lineStart [getPos]] + $ind + 2]
  332.     } else {
  333.         goto [lineStart [getPos]]
  334.     }
  335. }
  336. bind 'a' <z> shellBol Shel
  337.  
  338.  
  339. proc dummyShel {} {dummyTcl}
  340.  
  341. #================================================================================
  342.  
  343. proc shellup {} {
  344.     set pos [expr [lineStart [getPos]] - 1]
  345.     if {[catch {regexp {∞} [getText [lineStart $pos] [nextLineStart $pos]]} res] || !$res} {
  346.         previousLine; return
  347.     }
  348.     select [lineStart $pos] [nextLineStart $pos]
  349. }
  350. bind up shellup Shel
  351.  
  352.  
  353. proc shelldown {} {
  354.     set pos [nextLineStart [getPos]]
  355.     if {[catch {regexp {∞} [getText $pos [nextLineStart $pos]]} res] || !$res} {
  356.         nextLine; return
  357.     }
  358.     select $pos [nextLineStart $pos]
  359. }
  360. bind down shelldown Shel
  361.  
  362.         
  363. #================================================================================
  364. #####
  365. # (Usage:  'lt' sorts by time, like UNIX's 'ls -lt'.
  366. #          'lt -t' sorts by filename, like UNIX's 'ls -l'.
  367. #          Optionally a directory name can be added as an argument.)
  368.  
  369. proc sortdt {dt} {
  370.         scan $dt "%d/%d/%d {%d:%d:%d %1sM}" mon day yea hou min sec z
  371.         if {$z == "P"} {incr hou 12}
  372.         if {[string length $yea] == 1} {
  373.                 set year 200$yea
  374.         } elseif {$yea > 40} {
  375.                 set year 19$yea
  376.         } else {
  377.                 set year 20$yea
  378.         }
  379.         return [format "%04d%02d%02d%02d%02d" $year $mon $day $hou $min]
  380. }
  381.  
  382.  
  383. proc lth args {
  384.         global mode
  385.         
  386.         set val "*"
  387.         set sort 1
  388.         scan [lindex [mtime [now]] 0] "%d/%d/%d" one two three
  389.         if {[string length $three] == 1} {
  390.                 set year 200$three
  391.         } elseif {$three > 40} {
  392.                 set year 19$three
  393.         } else {
  394.                 set year 20$three
  395.         }
  396.         
  397.         foreach arg $args {
  398.                 switch -- $arg {
  399.                         "-t"    {set sort 0}
  400.                         default {set val $arg}
  401.                 }
  402.         }
  403.         set mod ""
  404.         foreach f [eval glob $val] {
  405.                 if {[catch {getFileInfo $f info}]} {
  406.                         if {$sort} {set mod "000000000000 "}
  407.                         lappend text [format "%s%s %8d%8d %6s %5s %4s %s %s\n" $mod "D" "0" "0" "" "" "" "DIR " [file tail $f]]
  408.                         continue
  409.                 }
  410.                 if {$sort} {set mod "[sortdt [mtime $info(modified) s]] "}
  411.                 set m [mtime $info(modified) a]
  412.                 set zer [lindex $m 0]
  413.                 set dat [format "%s %2s" [lindex $zer 1] [string trimright [lindex $zer 2] {,}]]
  414.                 if {[lindex $zer 3] == $year} {
  415.                         if {[scan [lindex $m 1] "%d:%d:%d %s" one two three am] != 4} {
  416.                                 error "Didn't get four from scan"
  417.                         }
  418.                         if {[string length $two] == 1} {set two "0$two"}
  419.                         set tm [expr {$am == "AM"} ? $one : [expr $one + 12]]:$two
  420.                 } else {
  421.                         set tm " [lindex $zer 3]"
  422.                 }
  423.                 lappend text [format "%sF %8d%8d %s %5s %s %s %s\n" $mod $info(datalen) $info(resourcelen) $dat $tm $info(type) $info(creator) [file tail $f]]
  424.         }
  425.         if {$sort} {
  426.                 foreach ln [lsort -de $text] {
  427.                         append txt [string range $ln 13 end]
  428.                 }
  429.                 set ans [string trimright $txt]
  430.         } else {
  431.                 set ans [string trimright [join $text {}]]
  432.         }
  433.         
  434.         if { $mode=="Shel" } { return $ans } else {
  435.                 new
  436.                 insertText $ans "\r"
  437.                 catch shrinkHeight
  438.                 setWinInfo dirty 0
  439.                 setWinInfo read-only 1
  440.         }
  441. }
  442.  
  443. #================================================================================
  444. proc ps {} {
  445.     foreach p [processes] {
  446.         append text [format "%-25s %4s %10d %10d\r" [lindex $p 0] [lindex $p 1] [lindex $p 2] [lindex $p 3]]
  447.     }
  448.     return [string trimright $text]
  449. }
  450.  
  451.  
  452. #================================================================================
  453. # Recursively make creator of all text files 'ALFA'. Optionally takes a starting
  454. # dir argument, otherwise starts in current directory. Auto-Doubled are no 
  455. # longer recognized by auto-doubler! Why? Some sort of conflict w/ 'PBSetFInfo'.
  456. proc creator {{dir ":"}}  {
  457.     if {![catch {glob -t TEXT $dir*} files]} {
  458.         foreach f $files {
  459.             message $f
  460.             setFileInfo $f creator ALFA
  461.         }
  462.     }
  463.  
  464.     if {![catch {glob $dir*} dirs]} {
  465.         foreach d $dirs {
  466.             if {[file isdir $d]} {creator $d:}
  467.         }
  468.     }
  469. }
  470.  
  471.  
  472.  
  473. #===============================================================================
  474.  
  475. proc ShelDblClick {args} { eval TclDblClick $args }
  476.  
  477. #===============================================================================
  478.  
  479. proc tomac args {
  480.     set files {}
  481.     foreach arg $args {
  482.         append files " " [glob $arg]
  483.     }
  484.     set dir [pwd]
  485.     
  486.     foreach f $files {
  487.         message "$f..."
  488.         set fd [open $dir$f "r"]
  489.         set text [read $fd]
  490.         close $fd
  491.         regsub "\n" $text "\r" text
  492.         
  493.         set fd [open "$dir$f" "w"]
  494.         puts -nonewline $fd $text
  495.         close $fd
  496.     }
  497.     message ""
  498. }
  499.  
  500.  
  501. #===============================================================================
  502.  
  503. proc unixToMac {fname} {
  504.     set fd [open $fname]
  505.     set text [read $fd]
  506.     close $fd
  507.     set fd [open $fname "w"]
  508.     puts -nonewline $fd $text
  509.     close $fd
  510. }
  511.  
  512. proc setCreator args {
  513.     set files {}
  514.     set creator [car $args]
  515.     foreach arg [cdr $args] {
  516.         append files " " [glob $arg]
  517.     }
  518.     
  519.     foreach f $files {
  520.         setFileInfo $f creator $creator
  521.     }
  522. }
  523.  
  524. proc setType args {
  525.     set files {}
  526.     set type [car $args]
  527.     foreach arg [cdr $args] {
  528.         append files " " [glob $arg]
  529.     }
  530.     
  531.     foreach f $files {
  532.         setFileInfo $f type $type
  533.     }
  534. }
  535. #===============================================================================
  536.